(in-package :iorek)

;;;Special operators

(defun %defvar (arguments env) ;;symbol &optional value
  (declare (ignore env))
  (let ((name (gensym "name")))
    `(let ((,name ,(@ arguments 0)))
       (record-definition ,name ,(@ arguments 1))
       ,name)))

(defun %defun (arguments env) ;;name args &rest body
  (let ((fdef (concat (seq *symbol-lang-lambda* (@ arguments 1))
                      (subseq arguments 2)))
        (name (gensym "name")))
    `(let ((,name ,(@ arguments 0)))
       (record-definition ,name ,(translate-form fdef env)
                          :kind *symbol-kind-function*)
       ,name)))

(defun %defmacro (arguments env) ;;name args &rest body
  (let ((fdef (concat (seq *symbol-lang-lambda* (@ arguments 1))
                      (subseq arguments 2)))
        (name (gensym "name")))
    `(let ((,name ,(@ arguments 0)))
       (record-definition ,name
                          (lambda (symbol environment arguments)
                            (declare (ignore symbol environment)) ;;TODO
                            (apply ,(translate-form fdef env) (seq-to-list arguments)))
                          :kind *symbol-kind-macro*)
       ,name)))

(record-definition *symbol-lang-defvar* '%defvar :kind :special-operator)
(record-definition *symbol-lang-defun* '%defun :kind :special-operator)
(record-definition *symbol-lang-defmacro* '%defmacro :kind :special-operator)

(record-definition *symbol-lang-true* *symbol-lang-true* :kind :constant) ;;TODO
(record-definition *symbol-lang-false* *symbol-lang-false* :kind :constant) ;;TODO

(defun %if (arguments env) ;;test true-branch &optional false-branch
  `(if (not (eq *symbol-lang-false* ,(translate-form (@ arguments 0) env)))
       ,(translate-form (@ arguments 1) env)
       ,(let ((false-branch (@ arguments 2)))
             (if false-branch (translate-form false-branch env) *symbol-lang-false*))))

(record-definition *symbol-lang-if* '%if :kind :special-operator)

;;Quote
(defun %quote (arguments env)
  (declare (ignore env))
  (unless (= (size arguments) 1)
    (error "Wrong number of arguments for quote: ~A" arguments))
  (first arguments))

(record-definition *symbol-lang-quote* '%quote :kind :special-operator)

;;Binding and assignment
(defun %let (arguments env)
  (translate-binding-form arguments env))

(defun translate-binding-form (arguments environment)
  (let ((augmented-environment (make-environment environment))
        binding-forms
        body)
    (do-seq (binding (first arguments)) ;;TODO error detection
      (let ((name (@ binding 0))
            (expr (translate-form (@ binding 1) environment)))
        (cond
          ((not (seq? name)) ;;Normal variable
           (let ((sym (cl:gensym (symbol-name name))))
             (record-definition name sym :environment augmented-environment
                                :kind :lexical-variable)
             (push `(let ((,sym ,expr))) binding-forms)))
          ((eq (@ name 0) *symbol-lang-function*) ;;(function ...)
           (let ((sym (cl:gensym (symbol-name (@ name 1))))) ;;TODO error detection
             (record-definition (@ name 1) sym :environment augmented-environment
                                :kind :lexical-function)
             (push `(let ((,sym ,expr))) binding-forms)))
          ((eq (@ name 0) *symbol-lang-values*) ;;(values ...)
           (let ((syms (seq-to-list
                        (image (lambda (s)
                                 (let ((sym (cl:gensym (symbol-name s))))
                                   ;;Side-effect!
                                   (record-definition s sym :environment augmented-environment
                                                      :kind :lexical-variable)
                                   sym))
                               (subseq name 1)))))
             ;;TODO (values (function ...) ...)
             (push `(multiple-value-bind ,syms ,expr) binding-forms)))
          (t (error "Unsupported binding form: ~A" binding)))))
    (do-seq (form (subseq arguments 1))
      (push (translate-form form augmented-environment) body))
    (let ((result `(progn ,@(nreverse body))))
      (dolist (form binding-forms)
        (setf result (append form (list result))))
      result)))

(defun %set (args env)
  (translate-variable-write (@ args 0) (@ args 1) env)) ;;TODO arg check

(record-definition *symbol-lang-let* '%let :kind :special-operator)
(record-definition *symbol-lang-!* '%set :kind :special-operator)

;;Functions
(defun %lambda (arguments environment)
  (let ((translated-bindings (list))
        (augmented-environment (make-environment environment))
        body)
    ;;TODO lambda-list parsing
    (do-seq (binding (first arguments)) ;;TODO error detection
      (let* ((var binding)
             (sym (cl:gensym (symbol-name var))))
        (record-definition var sym :environment augmented-environment :kind :lexical-variable)
        (push sym translated-bindings)))
    (do-seq (form (subseq arguments 1))
      (push (translate-form form augmented-environment) body))
    (let ((function `(lambda ,(nreverse translated-bindings)
            ,@(nreverse body))))
      `(function ,function))))

(record-definition *symbol-lang-lambda* '%lambda :kind :special-operator)

(defun pipe1 (arg0 fn &rest args)
  (apply fn arg0 args))

(defun pipe2 (arg1 fn arg0 &rest args)
  (apply fn arg0 arg1 args))

(defun pipe3 (arg2 fn arg0 arg1 &rest args)
  (apply fn arg0 arg1 arg2 args))

(defun pipe4 (arg3 fn arg0 arg1 arg2 &rest args)
  (apply fn arg0 arg1 arg2 arg3 args))

(record-definition *symbol-lang-\|* 'pipe1 :kind :lisp-function)
(record-definition *symbol-lang-\|\|* 'pipe2 :kind :lisp-function)
(record-definition *symbol-lang-\|\|\|* 'pipe3 :kind :lisp-function)
(record-definition *symbol-lang-\|\|\|\|* 'pipe4 :kind :lisp-function)

;;Misc
(defun %do (args env)
  (let ((form (list 'progn)))
    (do-seq (expr args)
      (push (translate-form expr env) form))
    (nreverse form)))

(record-definition *symbol-lang-do* '%do :kind :special-operator)

;;;Primitive variables defined in CL
(record-definition *symbol-lang-*namespace** '*namespace* :kind :lisp-variable)

;;;Primitive functions defined in CL

;;Environment
(record-definition *symbol-lang-symbol-value* 'symbol-value :kind :lisp-function)
(record-definition *symbol-lang-symbol-function* 'symbol-function :kind :lisp-function)

;;Arithmetic and relations
(record-definition *symbol-lang-+* 'cl:+ :kind :lisp-function)
(record-definition *symbol-lang--* 'cl:- :kind :lisp-function)
(record-definition *symbol-lang-** 'cl:* :kind :lisp-function)
(record-definition *symbol-lang-/* 'cl:/ :kind :lisp-function)
(record-definition *symbol-lang->* '%> :kind :lisp-function)
(record-definition *symbol-lang->=* '%>= :kind :lisp-function)
(record-definition *symbol-lang-<* '%< :kind :lisp-function)
(record-definition *symbol-lang-<=* '%<= :kind :lisp-function)
(record-definition *symbol-lang-=* '%= :kind :lisp-function)
(record-definition *symbol-lang-eq?* '%eq? :kind :lisp-function)
(record-definition *symbol-lang-eql?* '%eql? :kind :lisp-function)

(defun %> (number &rest more-numbers)
  (or (apply #'cl:> number more-numbers)
      *symbol-lang-false*))

(defun %< (number &rest more-numbers)
  (or (apply #'cl:< number more-numbers)
      *symbol-lang-false*))

(defun %>= (number &rest more-numbers)
  (or (apply #'cl:>= number more-numbers)
      *symbol-lang-false*))

(defun %<= (number &rest more-numbers)
  (or (apply #'cl:<= number more-numbers)
      *symbol-lang-false*))

(defun %= (number1 number2 &rest more-numbers)
  (or (apply #'cl:= number1 number2 more-numbers)
      *symbol-lang-false*))

(defun %eq? (obj1 obj2 &rest more-objs)
  (or (apply #'cl:eq obj1 obj2 more-objs)
      *symbol-lang-false*))

(defun %eql? (obj1 obj2 &rest more-objs)
  (or (apply #'cl:eql obj1 obj2 more-objs)
      *symbol-lang-false*))

;;Data structures
(defun %list (&rest args)
  (sequence-to-seq args))

(defun %adjoin (elem seq &optional (where 0))
  (insert seq where elem))

(defun %list? (obj)
  (or (seq? obj) *symbol-lang-false*))

(record-definition *symbol-lang-adjoin* '%adjoin :kind :lisp-function)
(record-definition *symbol-lang-append* 'concat :kind :lisp-function)
(record-definition *symbol-lang-list* '%list :kind :lisp-function)
(record-definition *symbol-lang-list?* '%list? :kind :lisp-function)
(record-definition *symbol-lang-lookup* 'lookup :kind :lisp-function)
(record-definition *symbol-lang-subseq* 'subseq :kind :lisp-function)

;;Reading
(record-definition *symbol-lang-read-object* 'read-object :kind :lisp-function)
(record-definition *symbol-lang-read-expression* 'read-expression :kind :lisp-function)
;;Printing
(defun %print (object &optional (stream *standard-output*))
  (print-object object stream))

(record-definition *symbol-lang-print* '%print :kind :lisp-function)

;;Symbols
(defun %namespace (symbol)
  (setf *namespace* symbol))

(record-definition *symbol-lang-alias* 'alias :kind :lisp-function)
(record-definition *symbol-lang-export* 'export :kind :lisp-function)
(record-definition *symbol-lang-find-symbol* 'find-symbol :kind :lisp-function)
(record-definition *symbol-lang-intern* 'intern :kind :lisp-function)
(record-definition *symbol-lang-namespace* '%namespace :kind :lisp-function)

;;Functions
(defun %apply (f &rest args)
  (apply f args)) ;;TODO handle last arg as seq

(defun %compose (f &rest fns)
  ;;TODO arglist
  (if fns
      (let ((c (apply #'%compose fns)))
        (lambda (&rest args)
          (funcall f (apply c args))))
      f))

(record-definition *symbol-lang-compose* '%compose :kind :lisp-function)
(record-definition *symbol-lang-map* 'image :kind :lisp-function)